######################################################################
#
# wrapper.tcl 
#
# This file defines wrapper procedures.  These
# procedures are called by functions in jabberlib, and
# they in turn call the TclXML library functions.
#
# $Header$
#
#
######################################################################
#
# Here is a list of the procedures defined here:
#
if {0} { 
proc wrapper:new {streamstartcmd streamendcmd parsecmd}
proc wrapper:free {id}
proc wrapper:parser {id args}
proc wrapper:reset {id}
proc wrapper:elementstart {id tagname varlist args}
proc wrapper:elementend {id tagname args}
proc wrapper:chdata {id chardata}
proc wrapper:xmlerror {id args}
proc wrapper:xmlcrypt {text}
proc wrapper:createxml {xmldata}
proc wrapper:createtag {tagname args}
proc wrapper:getattr {varlist attrname}
proc wrapper:isattr {varlist attrname}
proc wrapper:splitxml {xmldata vtag vvars visempty vchdata vchildren}
proc wrapper:streamheader {args}
proc wrapper:streamtrailer {}
}
#
#
######################################################################
#
set wrapper(list) ""
set wrapper(freeid) 0

######################################################################
proc wrapper:new {streamstartcmd streamendcmd parsecmd} {
    variable wrapper

    set id "wrap#$wrapper(freeid)"
    incr wrapper(freeid)

    lappend wrapper(list) $id

    set wrapper($id,streamstartcmd) $streamstartcmd
    set wrapper($id,streamendcmd)   $streamendcmd
    set wrapper($id,parsecmd)       $parsecmd

    set wrapper($id,parser) \
	[::xml::parser "_parser_$id" \
	     -namespace \
	     -final 0 \
	     -elementstartcommand  "[namespace current]::wrapper:elementstart [list $id]" \
	     -elementendcommand    "[namespace current]::wrapper:elementend [list $id]" \
	     -characterdatacommand "[namespace current]::wrapper:chdata [list $id]"
	 #   -errorcommand         "[namespace current]::wrapper:xmlerror [list $id]"
	]

    if {[info commands ::$wrapper($id,parser)] == ""} {
	set wrapper($id,parser) [namespace current]::$wrapper($id,parser)
    }

    set wrapper($id,stack) {}

    return $id
}

######################################################################
proc wrapper:free {id} {
    variable wrapper
    if {[set ind [lsearch $wrapper(list) $id]] == -1} {
	return -code error -errorinfo "No such wrapper: \"$id\""
    }
    set wrapper(list) [lreplace $wrapper(list) $ind $ind]
    $wrapper($id,parser) free
    array unset wrapper $id,*
}

######################################################################
proc wrapper:parser {id args} {
    variable wrapper
    if {[lsearch $wrapper(list) $id] == -1} {
	return -code error -errorinfo "No such wrapper: \"$id\""
    }

    return [uplevel 1 "[list $wrapper($id,parser)] $args"]
}

######################################################################
proc wrapper:reset {id} {
    variable wrapper
    if {[lsearch $wrapper(list) $id] == -1} {
	return -code error -errorinfo "No such wrapper: \"$id\""
    }

    $wrapper($id,parser) reset
    $wrapper($id,parser) configure \
	-final 0 \
	-elementstartcommand  "[namespace current]::wrapper:elementstart [list $id]" \
	-elementendcommand    "[namespace current]::wrapper:elementend [list $id]" \
	-characterdatacommand "[namespace current]::wrapper:chdata [list $id]" 
    #	-errorcommand         "[namespace current]::wrapper:xmlerror [list $id]"

    set wrapper($id,stack) {}
}

######################################################################
proc wrapper:elementstart {id tagname varlist args} {
    variable wrapper
    if {[lsearch $wrapper(list) $id] == -1} {
	return -code error -errorinfo "No such wrapper: \"$id\""
    }

    foreach {attr val} $args {
	switch -- $attr {
	    -namespace {lappend varlist xmlns $val}
	}
    }

    set idx [string last : $tagname]
    if {$idx >= 0} {
	lappend varlist xmlns [string range $tagname 0 [expr {$idx - 1}]]
	set tagname [string range $tagname [expr {$idx + 1}] end]
    }

    if {$wrapper($id,stack) == {}} {
	set wrapper($id,level1tag) $tagname
	uplevel #0 "$wrapper($id,streamstartcmd) [list $varlist]"
    }
    set wrapper($id,stack) \
	[linsert $wrapper($id,stack) 0 \
	     [list $tagname $varlist {} "" "" ""]]
}

######################################################################
proc wrapper:elementend {id tagname args} {
    variable wrapper
    if {[lsearch $wrapper(list) $id] == -1} {
	return -code error -errorinfo "No such wrapper: \"$id\""
    }

    set new_el [lindex $wrapper($id,stack) 0]
    set tail [lrange $wrapper($id,stack) 1 end]

    set len [llength $tail]

    if {$len > 1} {
	set head [lindex $tail 0]
	#set subtail [lrange $tail 1 end]
	set els [linsert [lindex $head 2] end $new_el]
	set wrapper($id,stack) \
	    [lreplace $tail 0 0 \
		 [lreplace $head 2 2 $els]]
    } elseif {$len == 1} {
	uplevel \#0 $wrapper($id,parsecmd) [list $new_el]
	set wrapper($id,stack) $tail
    } else { # $len == 0
	uplevel \#0 $wrapper($id,streamendcmd)
	set wrapper($id,stack) $tail
    }
}

######################################################################
proc wrapper:chdata {id chardata} {
    variable wrapper
    if {[lsearch $wrapper(list) $id] == -1} {
	return -code error -errorinfo "No such wrapper: \"$id\""
    }

    set new_el [lindex $wrapper($id,stack) 0]
    #set tail [lrange $wrapper($id,stack) 1 end]

    set chdata "[lindex $new_el 3]$chardata"
    set new_el [lreplace $new_el 3 3 $chdata]

    set els [lindex $new_el 2]
    if {$els == {}} {
	set new_el [lreplace $new_el 4 4 "[lindex $new_el 4]$chardata"]
    } else {
	set els [lindex $new_el 2]
	set last_el [lindex $els end]
	set last_el [lreplace $last_el 5 5 "[lindex $last_el 5]$chardata"]
	set els [lreplace $els end end $last_el]
	set new_el [lreplace $new_el 2 2 $els]
    }

    set wrapper($id,stack) [lreplace $wrapper($id,stack) 0 0 $new_el]
}

######################################################################
#
# Called when there's an error with parsing XML.
#
proc wrapper:xmlerror {id args} {
    variable wrapper
    if {[lsearch $wrapper(list) $id] == -1} {
	return -code error -errorinfo "No such wrapper: \"$id\""
    }

    LOG "XML Parsing Error: $args"
    uplevel #0 $wrapper($id,streamendcmd)
}

######################################################################
proc wrapper:xmlcrypt {text} {
    return [string map {& &amp; < &lt; > &gt; \" &quot; ' &apos;
			\x00 " " \x01 " " \x02 " " \x03 " "
			\x04 " " \x05 " " \x06 " " \x07 " "
			\x08 " "                   \x0B " "
			\x0C " "          \x0E " " \x0F " "
			\x10 " " \x11 " " \x12 " " \x13 " "
			\x14 " " \x15 " " \x16 " " \x17 " "
			\x18 " " \x19 " " \x1A " " \x1B " "
			\x1C " " \x1D " " \x1E " " \x1F " "} $text]
}

######################################################################
#
# This procedure converts (and returns) $xmldata to raw-XML
#
proc wrapper:createxml {xmldata {xmlns jabber:client}} {
    set retext ""

    set tagname [lindex $xmldata 0]
    set vars    [lindex $xmldata 1]
    set subtags [lindex $xmldata 2]
    set chdata  [lindex $xmldata 3]

    append retext "<$tagname"
    foreach {attr value} $vars {
	if {$attr == "xmlns"} {
	    if {$value == $xmlns} {
		continue
	    } else {
		set xmlns $value
	    }
	}
	append retext " $attr='[wrapper:xmlcrypt $value]'"
    }
    if {$chdata == "" && [llength $subtags] == 0} {
	append retext "/>"
	return $retext
    } else {
	append retext ">"
    }

    append retext [wrapper:xmlcrypt $chdata]

    foreach subdata $subtags {
	append retext [wrapper:createxml $subdata $xmlns]
    }

    append retext "</$tagname>"

    return $retext
}

######################################################################
#
# This proc creates (and returns) xmldata of tag $tagname, 
# with the parameters given.
#
# Parameters:
#  -empty   0|1         Is this an empty tag? If $chdata 
#                       and $subtags are empty, then whether 
#                       to make the tag empty or not is decided 
#                       here. (default: 1)
#
#	-vars    {attr1 value1 attr2 value2 ..}   Vars is a list 
#                       consisting of attr/value pairs, as shown.
#
#	-chdata  $chdata    ChData of tag (default: ""), if you use 
#                       this attr multiple times, new chdata will 
#                       be appended to old one.
#
#	-subtags $subchilds $subchilds is a list containing xmldatas 
#                       of $tagname's subtags. (default: no sub-tags)
#
proc wrapper:createtag {tagname args} {

    set isempty 1
    set vars    ""
    set chdata  ""
    set subtags ""

    foreach {attr val} $args {
	switch -- $attr {
	    -empty   {set isempty $val}
	    -vars    {set vars $val}
	    -chdata  {set chdata $chdata$val}
	    -subtags {set subtags $val}
	}
    }

    set retext [list $tagname $vars $subtags $chdata "" ""]

    return $retext
}

######################################################################
#
# This proc returns the value of $attr from varlist
#
proc wrapper:getattr {varlist attrname} {

  foreach {attr val} $varlist {
	if {$attr == $attrname} {return $val}
  }
  return ""
}

######################################################################
#
# This proc returns 1, or 0, depending on the attr exists in varlist or not
#
proc wrapper:isattr {varlist attrname} {

  foreach {attr val} $varlist {
	if {$attr == $attrname} {return 1}
  }
  return 0
}

######################################################################
#
# This proc splits the xmldata to 5 different variables.
#
proc wrapper:splitxml {xmldata vtag vvars visempty vchdata vchildren} {
    set tag      [lindex $xmldata 0]
    set vars     [lindex $xmldata 1]
    set children [lindex $xmldata 2]
    set chdata   [lindex $xmldata 3]
    
    uplevel 1 "set [list $vtag]      [list $tag] \n     \
               set [list $vvars]     [list $vars] \n    \
               set [list $visempty]  0 \n \
               set [list $vchdata]   [list $chdata] \n  \
               set [list $vchildren] [list $children]"
}

proc wrapper:get_subchdata {xmldata} {
    lindex $xmldata 4
}

proc wrapper:get_fchdata {xmldata} {
    lindex $xmldata 5
}


######################################################################
#
# This proc returns stream header
#
proc wrapper:streamheader {to args} {
    set to [wrapper:xmlcrypt $to]
    set xmlns_stream [wrapper:xmlcrypt "http://etherx.jabber.org/streams"]
    set xmlns [wrapper:xmlcrypt "jabber:client"]
    set lang ""
    set version ""
    foreach {opt val} $args {
	switch -- $opt {
	    -xmlns:stream {
		set xmlns_stream [wrapper:xmlcrypt $val]
	    }
	    -xmlns {
		set xmlns [wrapper:xmlcrypt $val]
	    }
	    -xml:lang {
		set lang " xml:lang='[wrapper:xmlcrypt $val]'"
	    }
	    -version {
		set version " version='$val'"
	    }
	}
    }
    return "<stream:stream xmlns:stream='$xmlns_stream'\
	    xmlns='$xmlns'$lang to='$to'$version>"
}

######################################################################
#
# This proc returns stream trailer
#
proc wrapper:streamtrailer {} {
    return "</stream:stream>"
}

